home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.09 Sep 89 / Data Editor Source / Listing One < prev    next >
Encoding:
Text File  |  1988-08-26  |  11.1 KB  |  476 lines  |  [TEXT/EDIT]
  1. ******************************************************************
  2. *                                                                *
  3. *  Data Editor                                                   *
  4. *  © 1988 by Mark E. McBride                                     *
  5. *            1205 Dana Drive                                     *
  6. *            Oxford, OH  45056                                   *
  7. *                                                                *
  8. *  Developed using Absoft MacFortran/020 and FaceIt.             *
  9. *  Program provides a Mac user interface to which number         *
  10. *  crunching routines can easily be added.  Takes advantage      *
  11. *  of FaceIt's general event loop, standard Mac environment,     *
  12. *  sheet windows.                                                *
  13. *                                                                *
  14. ******************************************************************
  15.  
  16.       PROGRAM DataEdit
  17.     real*8 pt(1)
  18.     call main(pt)
  19.     end
  20.     
  21.     Subroutine main(pt)
  22.     implicit none
  23.  
  24. *  Absoft toolbox parameter equates, change pathname to reflect
  25. *  your disk setup.
  26.     include HD40:Fortran:Include Files:memory.inc
  27.     INTEGER PTR
  28.     PARAMETER (PTR=Z'C0000000')
  29.  
  30. *  Local variables
  31.     real*8 pt(*)
  32.       integer*4 toolbx,i,j,npt,PtPtr,PtHdl
  33.     integer*4 action,nmax,kmax
  34.     character*256 Head,saveMAC
  35.     logical*1 check
  36.     
  37. *  Include FaceIt declarations
  38.     include HD40:Fortran:FaceIt:StorMF.inc
  39.  
  40. *    load JumpMF     !!!REMOVE this line if JumpMF is linked to program!!!
  41. *    load toolbx  !!!REMOVE this line if toolbx is linked to program!!!
  42.  
  43.       name = 'DEdit.Rsrc'           !temporary resource file
  44.       call FaceIt(1,1,-1,50,1,2)    !initialize FaceIt
  45.  
  46. *  setup default array information
  47.     data nmax/100/
  48.     data kmax/2/
  49.     
  50. *  set initial sheet to 1x1 array so that open command
  51. *  is available, do not hide sheet
  52. *  sheet window must be active window to get open routine
  53. *  called for the sheet.
  54.     PtPtr=0                !pointer to pt array
  55.     PtHdl=0                !handle to pt array
  56.  
  57. * The use of "1" for the first argument of the SetSh1 command
  58. * indicates that we will support "Open", "Save As", and "Save"
  59. * for this sheet.
  60.     pt(0)=0
  61.     name='empty'
  62.     arrayptr(1) = toolbx(PTR,pt)
  63.     call FaceIt(1,SetSh1,1,1,0,-6)
  64.     call FaceIt(0,ShoSh1,RetCtl,0,0,0)
  65. *
  66. *  Set Means... menu off until an array has been tagged to
  67. *  the sheet.
  68. *
  69.       call UpdateMenu(menuhdl(5),PtPtr)
  70.       
  71.  
  72.  
  73. *  Main loop
  74.       do
  75.         call FaceIt(0,0,0,0,0,0)           !give control to user
  76.         
  77.       select case (MAC)
  78.       
  79.         case('About')
  80.           call FaceIt(0,OpnAlt,1009,0,0,0)  !open "About Data Editor" alert
  81.  
  82. *  The points can be loaded from a DEdit data file.  The data format
  83. *  consists of nmax, kmax, then the kmax string titles, finally, the data.
  84.         case('Open')
  85.           Head='opening sheet'
  86.         action=0
  87.         if (PtPtr<>0) then
  88.           call FaceIt(1,FixSh1,RetCtl,0,0,0)
  89.           call SaveIt(Head,action)
  90.         end if
  91.         if (action=1)
  92.      +        call SaveDa(pt,nmax*kmax,nmax,kmax)
  93.         MAC = 'DPTE'
  94.         if (action<3) call FaceIt(0,StdOpn,0,0,0,0)
  95.         if ((name<>'Cancel').and.(action<3)) then
  96.           if (PtPtr<>0)
  97.      +        call toolbx(DISPOSHANDLE,PtHdl)
  98.           open(3,file = name,status = 'old',
  99.      +                      form='unformatted')
  100.           read(3)nmax,kmax
  101.           I4=nmax*kmax*8
  102.           call FaceIt(0,NewBlk,0,0,0,0)
  103.           if (I4<>0) then
  104.             PtHdl=I4
  105.             PtPtr=long(I4)
  106.             call dynam(PtPtr)
  107.           else
  108.             MAC='Failed to allocate memory.'
  109.             call FaceIt(0,OpnAlt,1005,0,0,0)
  110.             stop
  111.           end if
  112.           do (i=1,nmax*kmax)
  113.             pt(i)=0
  114.           repeat
  115.           do (i=1,kmax)
  116.             read(3)Head
  117.             MAC=trim(Head)
  118.             call FaceIt(0,SetStr,1001,i,0,0)
  119.           repeat
  120.           read(3)(pt(i),i=1,nmax*kmax)
  121.           close(3)
  122.           arrayptr(1) = toolbx(PTR,pt)
  123.           call FaceIt(1,SetSh1,nmax,kmax,0,-6)
  124.           fixrect(1)=1;fixrect(2)=1;
  125.           fixrect(3)=nmax;fixrect(4)=kmax;
  126.           call FaceIt(1,FixSh1,0,0,0,0)
  127.         end if
  128.         
  129. * We also support the saving of points back to disk...
  130.         case('Save As','Save')
  131.           if (MAC='Save As') name=''
  132.         call SaveDa(pt,nmax*kmax,nmax,kmax)
  133.           
  134. * Create a new array and tag it to the sheet window
  135.         case('New Sheet')
  136.           Head='setting new sheet'
  137.         action=0
  138.         if (PtPtr<>0) then
  139.           call FaceIt(1,FixSh1,RetCtl,0,0,0)
  140.           call SaveIt(Head,action)
  141.         end if
  142.         if (action=1)
  143.      +        call SaveDa(pt,nmax*kmax,nmax,kmax)
  144.         check=.false.
  145.         if (action<3) call NewDlg(nmax,kmax,check)
  146.         if ((check).and.(action<3)) then 
  147.             if (PtPtr<>0)
  148.      +            call toolbx(DISPOSHANDLE,PtHdl)
  149.           I4=nmax*kmax*8
  150.           call FaceIt(0,NewBlk,0,0,0,0)
  151.           if (I4<>0) then
  152.             PtHdl=I4
  153.             PtPtr=long(I4)
  154.             call dynam(PtPtr)
  155.           else
  156.             MAC='Failed to allocate memory.'
  157.             call FaceIt(0,OpnAlt,1005,0,0,0)
  158.             stop
  159.           end if
  160.           do (i=1,nmax*kmax)
  161.             pt(i)=0
  162.           repeat
  163.           name=''
  164.           do (i=1,kmax)
  165.             I4=i
  166.             call FaceIt(0,I4ToS,0,0,0,0)
  167.             MAC='X'//trim(MAC)
  168.             call FaceIt(0,SetStr,1001,i,0,0)
  169.           repeat
  170.           arrayptr(1) = toolbx(PTR,pt)
  171.           call FaceIt(1,SetSh1,nmax,kmax,0,-6)
  172.           fixrect(1)=1;fixrect(2)=1;
  173.           fixrect(3)=nmax;fixrect(4)=kmax;
  174.           call FaceIt(1,FixSh1,0,0,0,0)
  175.         end if
  176.  
  177.         case('Quit','Transfer')
  178.           saveMAC=MAC
  179.         if (MAC='Quit')Head='Quitting'
  180.         if (MAC='Transfer')Head='Transferring'
  181.         action=0
  182.         if (PtPtr<>0) then
  183.           call FaceIt(1,FixSh1,RetCtl,0,0,0)
  184.           call SaveIt(Head,action)
  185.         end if
  186.         if (action=1)
  187.      +        call SaveDa(pt,nmax*kmax,nmax,kmax)
  188.         if (action<3) then
  189.           if (saveMAC='Quit') then
  190.             call FaceIt(0,DoQuit,0,0,0,0)      !complete Quit
  191.           else if (saveMAC='Transfer') then
  192.             call FaceIt(0,DoTran,0,0,0,0)      !complete Transfer
  193.           end if
  194.         end if
  195.  
  196.         case('Means...')
  197.           call Means(pt,nmax,kmax)
  198.         
  199.         case default
  200.       
  201.       end select
  202.  
  203.       call UpdateMenu(menuhdl(5),PtPtr)
  204.       
  205.       
  206.     repeat
  207.  
  208.       end
  209.  
  210.  
  211. *
  212. * The following menu-updating routine keeps a single menu item
  213. * updated.
  214. *
  215.     SUBROUTINE UpdateMenu(amenuhdl,aPtr)
  216.     implicit none
  217.       INTEGER ENABLEITEM
  218.       PARAMETER (ENABLEITEM=Z'93911000')
  219.     INTEGER DISABLEITEM
  220.     PARAMETER (DISABLEITEM=Z'93A11000')
  221.     integer*4 amenuhdl,aPtr
  222.     if (aPtr<>0) then                !data in array
  223.       call toolbx(ENABLEITEM,amenuhdl,1)
  224.     else
  225.       call toolbx(DISABLEITEM,amenuhdl,1)
  226.     end if
  227.     end
  228.  
  229. *
  230. *  Write data to output file
  231. *
  232.     Subroutine SaveDa(pt,npts,nmax,kmax)
  233.     implicit none
  234.  
  235.       real*8 pt(npts)
  236.     integer*4 i,npts,nmax,kmax
  237.     character*256 Head
  238.     
  239.       include HD40:Fortran:FaceIt:StorMF.inc
  240.     
  241.     if (trim(name)='') then
  242.       MAC = 'Save data points as'
  243.       call FaceIt(0,StdSav,0,0,0,0)
  244.     end if
  245.     if (name <> 'Cancel') then
  246.       open(3,file = name,status = 'new',form='unformatted')
  247.       write(3)nmax,kmax
  248.       do (i=1,kmax)
  249.         call FaceIt(0,GetStr,1001,i,0,0)
  250.         Head=trim(MAC)
  251.         write(3)Head
  252.       repeat
  253.       write(3)(pt(i),i=1,npts)
  254.       close(3)
  255.       call FaceIt(1,MovSh1,0,0,0,0)  !reset title
  256.       MAC = 'DPTE'
  257.       call FaceIt(0,SetTyp,RetCtl,0,0,0)
  258.       end if
  259.     
  260.     end
  261.  
  262. *
  263. *  The means subroutine calculates the means of the selected variables
  264. *  Over the selected observations
  265. *
  266.     Subroutine Means(pt,nmax,kmax)
  267.     
  268.     implicit none
  269.  
  270.     integer*4 nmax,kmax
  271.     real*8 pt(nmax,kmax),sum,xbar
  272.       integer*4 toolbx,i,j
  273.     integer*4 nbeg,nend,kbeg,kend
  274.     character*80 head(10),temp
  275.     logical*1 check
  276.  
  277.       include HD40:Fortran:FaceIt:StorMF.inc
  278.  
  279. *  call dialog to get observations and variables
  280.  
  281.     call SelObs(nbeg,nend,nmax,kmax,check)
  282.     
  283.     if (check) then
  284.  
  285. *  Write out headers, first select output window
  286. *  then write out information
  287.       
  288.       head(1)='Calculated Means'
  289.       head(2)=''
  290.       write(temp,'(i5)') nbeg
  291.       head(3)='Observations:  # '//trim(temp)
  292.       write(temp,'(i5)') nend
  293.       head(3)=trim(head(3))//' to # '//trim(temp)
  294.       head(4)=''
  295.       do (i=1,4)
  296.         MAC=head(i)
  297.         call FaceIt(-1,RetCtl,0,0,0,0)
  298.       repeat
  299.   
  300. *  Calculate Means and print out results
  301.  
  302.       kbeg=0
  303.       kend=0
  304.       do (j=1,kmax)
  305.         call FaceIt(0,GetStr,1001,j,0,0)
  306.         if (MAC(1:1)='*') then
  307.           if (kbeg=0) kbeg=j
  308.         if ((kend=0).or.(kbeg>0)) kend=j
  309.           sum=0
  310.         do (i=nbeg,nend)
  311.           sum=sum+pt(i,j)
  312.         repeat
  313.         xbar=sum/(nend-nbeg+1)
  314.         write(temp,'(f12.6)') xbar
  315.         call FaceIt(0,GetStr,1001,j,0,0)
  316.         MAC='Mean of '//trim(MAC(2:22))//'= '//trim(temp)
  317.         call FaceIt(-1,RetCtl,0,0,0,0)
  318.         end if
  319.       repeat
  320.       selrect1(1)=nbeg
  321.       selrect1(3)=nend
  322.       selrect1(2)=kbeg
  323.       selrect1(4)=kend
  324.       fixrect(1)=1;fixrect(2)=1;
  325.       fixrect(3)=nmax;fixrect(4)=kmax;
  326.       call FaceIt(0,FixSh1,0,0,0,0)
  327.     end if
  328.     do (j=1,kmax)
  329.       call FaceIt(0,GetStr,1001,j,0,0)
  330.       if (MAC(1:1)='*') then
  331.         MAC=MAC(2:len(trim(MAC)))
  332.         call FaceIt(0,SetStr,1001,j,0,0)
  333.       end if
  334.     repeat    
  335.     MAC=' '
  336.     call FaceIt(-1,RetCtl,0,0,0,0)
  337.     MAC=' '
  338.     call FaceIt(-1,RetCtl,0,0,0,0)
  339.     
  340.     end
  341.  
  342.  
  343. *
  344. *  Set bounds for a new sheet
  345. *
  346.     subroutine NewDlg(nmax,kmax,check)
  347.  
  348.     implicit none
  349.  
  350.       integer*4 toolbx,i,nmax,kmax,avail
  351.     integer*2 mydialog(7)
  352.     logical*1 check
  353.     character*256 oldname
  354.     
  355. *  Absoft toolbox parameter equates, change pathname for your setup
  356.     include HD40:Fortran:Include Files:memory.inc
  357.  
  358.       include HD40:Fortran:FaceIt:StorMF.inc
  359.  
  360.     save mydialog
  361.     
  362.     data mydialog/0,0,-2,0,-2,0,-2/
  363.  
  364.     oldname=name
  365.     write(name,10) nmax,kmax
  366. 10    format(2i8)
  367.     do (i = 1,7)
  368.       dialog(i) = mydialog(i)
  369.     repeat
  370.     check=.false.
  371.     avail=toolbx(COMPACTMEM,8000000)
  372.     while (check<>.true.)
  373.       call FaceIt(0,OpnDlg,1010,0,0,0)      !open dialog #1010
  374.       if (dialog(1) = 1) then
  375.         read(name,12) nmax,kmax
  376. 12        format(2i8)
  377.         if (nmax*kmax*8>avail-20000) then
  378.           write(MAC,*)'Not enough memory. ',
  379.      +      (avail-20000)/8,' cells available.  ',
  380.      +      'Click to continue.'
  381.         call FaceIt(0,OpnAlt,1005,0,0,0)
  382.         else
  383.           check=.true.
  384.         do (i = 1,7)                       !update all values
  385.           mydialog(i) = dialog(i)
  386.         repeat
  387.         end if
  388.       else if (dialog(2)=1) then
  389.         check=.false.
  390.         call FaceIt(0,RetCtl,0,0,0,0)        !close dialog window
  391.         name=oldname
  392.         return
  393.       end if
  394.     repeat
  395.     call FaceIt(0,RetCtl,0,0,0,0)        !close dialog window
  396.     
  397.     end
  398.  
  399.  
  400. *
  401. *  Set observations to perform means on
  402. *
  403.     subroutine SelObs(nbeg,nend,nmax,kmax,check)
  404.  
  405.     implicit none
  406.  
  407.       integer*4 nbeg,nend,nmax,kmax
  408.     integer*4 toolbx,i,j
  409.     integer*2 mydialog(8)
  410.     logical*1 check
  411.     character*256 oldname
  412.     
  413.       include HD40:Fortran:FaceIt:StorMF.inc
  414.  
  415.      data mydialog/0,0,-2,0,-2,0,-2,0/
  416.  
  417.     oldname=name
  418.     write(name,10) selrect1(1),selrect1(3)
  419. 10    format(2i8)
  420.     do (j=selrect1(2),selrect1(4))
  421.       call FaceIt(0,GetStr,1001,j,0,0)
  422.       MAC='*'//trim(MAC)
  423.       call FaceIt(0,SetStr,1001,j,0,0)
  424.     repeat
  425.     do (i = 1,8)
  426.       dialog(i) = mydialog(i)
  427.     repeat
  428.     listID(1)=-1001
  429.     check=.false.
  430.     while (check<>.true.)
  431.       call FaceIt(0,OpnDlg,1020,0,0,0)         !open dialog #1020
  432.       if (dialog(1) = 1) then
  433.         read(name,12) nbeg,nend
  434. 12        format(2i8)
  435.       if (nend>nmax) nend=nmax
  436.         do (i = 1,8)                          !update all values
  437.         mydialog(i) = dialog(i)
  438.         repeat
  439.         check=.true.
  440.       else if (dialog(2)=1) then
  441.         call FaceIt(0,RetCtl,0,0,0,0)        !close dialog window
  442.         check=.false.
  443.         name=oldname
  444.         return
  445.       end if
  446.     repeat
  447.     name=oldname
  448.  
  449.     call FaceIt(0,RetCtl,0,0,0,0)              !close dialog window
  450.     
  451.     end
  452.  
  453.  
  454. *
  455. *  check whether to save Data before opening
  456. *
  457.     subroutine SaveIt(what,action)
  458.  
  459.     implicit none
  460.  
  461.     integer*4 action
  462.     character*256 what
  463.     
  464.       include HD40:Fortran:FaceIt:StorMF.inc
  465.  
  466.     write(MAC,'(2a64)')trim(name),trim(what)
  467.     call FaceIt(0,OpnAlt,1030,0,0,0)
  468.     action=dialog(1)
  469.     
  470.  
  471.     end
  472.  
  473.  
  474. *  Include FaceIt declarations
  475.       include HD40:Fortran:FaceIt:FaceMF.inc
  476.